perm filename TRUNC.F4[SCR,LCS] blob
sn#369213 filedate 1978-07-26 generic text, type T, neo UTF8
SUBROUTINE TRUNC
DIMENSION PX(2496),PXL(2496)
C 96*27=2592 STARTS WITH PARAM #4 → 99.
COMMON INUM,L,CNT(1) /COPY/NUMP,COPY(1) /COPYL/COPYL(1)
1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
1 K,NPAR,N,TBG,AC,NPA
IF(INUM.NE.1)GO TO 5
L=0
CALL TRUNCX(COPY,COPYL)
RETURN
5 L=(INUM-2)*96-3
IF(CNT(INUM).GT.1)GO TO 3
C INIT THE LIST.
DO 4 K=4,NPA
4 PX(K+L)='$'
3 CALL TRUNCX(PX,PXL)
END
SUBROUTINE TRUNCX(PX,PXL)
DIMENSION PX(1),PXL(1)
C 96*27=2592 STARTS WITH PARAM #4 → 99.
COMMON INUM,L,CNT(1) /P/P(1) /PL/PL(1)
1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
1 K,NPAR,N,TBG,AC,NPA
NPX=0
DO 1 K=NPA,4,-1
N=K+L
X=PL(K)
IF(P(K).NE.PX(N))GO TO 2
IF(X.GT.2)GO TO 2
IF(X.EQ.PXL(N))GO TO 1
2 IF(NPX.EQ.0)NPX=K
PX(N)=P(K)
PXL(N)=X
1 CONTINUE
NPA=3
IF(NPX.NE.0)NPA=NPX
END